DS-CD ROM 2 1993 August/DS CD-ROM 2.Ausgabe (August 1993).iso/programm/ds0045/spritsrc.exe/SPRITLIB.BAK

Text File | 1991-08-30 | 12KB | 390 lines

unit spritlib;          {Sprite-Library für Turbo Pascal V1.2 vom 29.01.1991}

interface
uses graph;

const max_sprites=12;   {Maximalzahl der Sprites, die benutzt werden können}

type    kollision_feld_typ = array [0..max_sprites-1] of boolean;
        sprite_feld_record = record
                             frei   : boolean;
                             x_gr   : byte;
                             y_gr   : byte;
                             o_nr   : byte;
                             e_merk : word;
                             m_merk : word;
                             x_pos  : word;
                             y_pos  : word;
                             memuse : word;
                             datenp : pointer;
                             savep  : pointer;
                             o_list : array [0..max_sprites-1] of byte;
                             s_list : array [0..max_sprites-1] of byte;
                          end;

var  sprite_error   : integer;
     init_count     : integer;
     sprite_daten   : array [0..1027] of byte;
     sprite_feld    : array [0..max_sprites-1] of sprite_feld_record;
     hide_list      : array [0..max_sprites-1] of byte;
     kol_list       : kollision_feld_typ;
     n_image_size   : integer;

procedure load_sprite (fname : string ; var nummer : integer);
procedure unload_sprite (nummer : integer);
procedure show_sprite (n,x,y,e,m : integer);
procedure hide_sprite (n : integer);
procedure print_sprite (n,x,y,e,m : integer);
procedure move_sprite (n,x,y : integer);
procedure sprite_pos (n : integer ; var x,y : integer);
function sprite_kol (n : integer) : boolean;

implementation

function nummer_ok(n : integer) : boolean;
begin
if (n<0) or (n>max_sprites-1) then nummer_ok:=false else nummer_ok:=true;
end;

function koords_ok(x,y,dx,dy : integer) : boolean;
begin
if (x<0) or (y<0) or (x+dx-1>getmaxx) or (y+dy-1>getmaxy) then koords_ok:=false
else koords_ok:=true;
end;

function extras_ok(e,m : integer) : boolean;
begin
if (e<0) or (e>3) or (m<0) or (m>4) then extras_ok:=false
else extras_ok:=true;
end;

function grafik_aktiv : boolean;
var dummy : integer;
begin
dummy:=getgraphmode;
if graphresult=0 then grafik_aktiv:=true else grafik_aktiv:=false;
end;

function match(n,m : integer) : boolean;
var exu,exo,eyu,eyo : integer;
begin
match:=false;
exu:=sprite_feld[m].x_pos+sprite_feld[m].x_gr-1;
exo:=sprite_feld[n].x_pos+sprite_feld[n].x_gr-1;
if ((exu-exo)>-sprite_feld[n].x_gr) and ((exu-exo)<sprite_feld[m].x_gr) then
begin
   eyu:=sprite_feld[m].y_pos+sprite_feld[m].y_gr-1;
   eyo:=sprite_feld[n].y_pos+sprite_feld[n].y_gr-1;
   if (eyu-eyo)>-sprite_feld[n].y_gr then
   if (eyu-eyo)<sprite_feld[m].y_gr then match:=true
   end;
end;

function daten_retten(x,y,dx,dy,mem : word ; var savep : pointer) : integer;
begin
if memavail-4096 < mem then daten_retten:=-5 else begin
   getmem(savep,mem);
   getimage(x,y,x+dx-1,y+dy-1,savep^);
   daten_retten:=0;
   end;
end;

procedure transfer_sprite(var nummer : integer ; konvert : boolean);
var count,t,u : integer;
begin
count:=-1;
repeat inc(count) until sprite_feld[count].frei or (count=max_sprites-1);
if sprite_feld[count].frei then with sprite_feld[count] do begin
   x_gr:=sprite_daten[2];
   y_gr:=sprite_daten[3];
   memuse:=imagesize(1,1,x_gr,y_gr);
   if not konvert then if memuse<>n_image_size then begin
      nummer:=-11;
      exit;
      end;
   if memavail-4096 < memuse then nummer:=-5 else begin
      getmem(datenp,memuse);
      nummer:=daten_retten(0,0,x_gr,y_gr,memuse,savep);
      if nummer=0 then if konvert then begin
         for t:=0 to x_gr-1 do for u:=0 to y_gr-1 do
         putpixel(t,u,sprite_daten[4+t*32+u]);
         getimage(0,0,x_gr-1,y_gr-1,datenp^);
         putimage(0,0,savep^,0);
         freemem(savep,memuse);
         savep:=nil;
         frei:=false;
         nummer:=count;
         end
      else begin
         for t:=0 to memuse-1 do
         byte(ptr(seg(datenp^),ofs(datenp^)+t)^):=sprite_daten[t+4];
         freemem(savep,memuse);
         savep:=nil;
         frei:=false;
         nummer:=count;
         end;
      end;
   end
else nummer:=-4;
end;

procedure load_sprite (fname : string ; var nummer : integer);
var myfile : file;
    mfsize : longint;
begin
sprite_error:=0;
{$I-}
assign(myfile,fname);
reset(myfile,1);
mfsize:=filesize(myfile);
close(myfile);
{$I+}
if ioresult<>0 then sprite_error:=-2 else
if (mfsize<10) or (mfsize>1028) then sprite_error:=-3;
if sprite_error=0 then begin
   {$I-}
   assign(myfile,fname);
   reset(myfile,mfsize);
   blockread(myfile,sprite_daten[0],1);
   close(myfile);
   {$I+}
   end;
if ioresult<>0 then sprite_error:=-2;
if (sprite_daten[0]<>84) or (sprite_daten[1]<>83) then sprite_error:=-3;
if sprite_error=0 then begin
   if mfsize=1028 then begin
      if not grafik_aktiv then sprite_error:=-1 else begin
         transfer_sprite(nummer,true);
         if nummer<0 then sprite_error:=nummer;
         end;
      end
   else begin
      if not grafik_aktiv then sprite_error:=-1 else begin
         n_image_size:=mfsize-4;
         transfer_sprite(nummer,false);
         if nummer<0 then sprite_error:=nummer;
         end;
      end;
   end;
end;

procedure unload_sprite(nummer : integer);
begin
if not nummer_ok(nummer) then sprite_error:=-6 else begin
   if sprite_feld[nummer].frei then sprite_error:=-7
   else with sprite_feld[nummer] do begin
      freemem(datenp,memuse);
      if savep<>nil then freemem(datenp,memuse);
      savep:=nil;
      frei:=true;
      sprite_error:=0;
      end;
   end;
end;

procedure get_koords(n : integer ; var x,y : integer ; e : integer);
begin
case e of
   0 : ;
   1 : x:=x-sprite_feld[n].x_gr+1;
   2 : begin
          x:=x-sprite_feld[n].x_gr+1;
          y:=y-sprite_feld[n].y_gr+1;
          end;
   3 : y:=y-sprite_feld[n].y_gr+1
   end;
end;

procedure set_o_list (n,m : integer);
begin
if sprite_feld[m].frei=false then with sprite_feld[m] do begin
   if savep<>nil then if n<>m then if match(n,m) then
   if o_list[n]=0 then begin
      inc(o_nr);
      o_list[n]:=o_nr;
      s_list[o_nr]:=n;
      end;
   end;
end;

procedure clear_o_list (n : integer);
var t,u: integer;
begin
for t:=0 to max_sprites-1 do
if sprite_feld[t].frei=false then if n<>t then with sprite_feld[t] do begin
   if savep<>nil then if o_list[n]>0 then begin
      u:=o_list[n];
      while (u<max_sprites-1) and (s_list[u+1]<>255) do begin
         dec (o_list[s_list[u+1]]);
         s_list[u]:=s_list[u+1];
         inc(u);
         end;
      o_list[n]:=0;
      s_list[u]:=255;
      dec(o_nr);
      end;
   end;
end;

procedure show_sprite (n,x,y,e,m : integer);
var t : integer;
begin
if not nummer_ok(n) then sprite_error:=-6 else with sprite_feld[n] do begin
   if frei=true then sprite_error:=-7 else begin
      if not extras_ok(e,m) then sprite_error:=-9 else begin
         get_koords(n,x,y,e);
         if not koords_ok(x,y,x_gr,y_gr) then sprite_error:=-8 else begin
            if savep<>nil then freemem(savep,memuse);
            sprite_error:=daten_retten(x,y,x_gr,y_gr,memuse,savep);
            if sprite_error=0 then begin
               putimage(x,y,datenp^,m);
               x_pos:=x;
               y_pos:=y;
               e_merk:=e;
               m_merk:=m;
               o_nr:=0;
               for t:=0 to max_sprites-1 do begin
                   o_list[t]:=0;
                   s_list[t]:=255;
                   set_o_list(n,t)
                   end;
               end;
            end;
         end;
      end;
   end;
end;

procedure review_sprite (n,s : integer);
var t : integer;
begin
if hide_list[n]=s then with sprite_feld[n] do begin
   hide_list[n]:=255;
   sprite_error:=daten_retten(x_pos,y_pos,x_gr,y_gr,memuse,savep);
   if sprite_error=0 then begin
      putimage(x_pos,y_pos,datenp^,m_merk);
      if o_nr>0 then for t:=1 to o_nr do review_sprite(s_list[t],n);
      end;
   end;
end;

procedure unview_sprite(n,s : integer);
var t : integer;
begin
if hide_list[n]=255 then with sprite_feld[n] do begin
   hide_list[n]:=s;
   if o_nr>0 then for t:=o_nr downto 1 do unview_sprite(s_list[t],n);
   putimage(x_pos,y_pos,savep^,0);
   freemem(savep,memuse);
   savep:=nil;
   end;
end;

procedure hide_sprite(n : integer);
var t : integer;
begin
if not nummer_ok(n) then sprite_error:=-6 else begin
   if sprite_feld[n].frei then sprite_error:=-7
   else with sprite_feld[n] do begin
      if savep=nil then sprite_error:=-10 else begin
         for t:=0 to max_sprites-1 do hide_list[t]:=255;
         if o_nr>0 then for t:=o_nr downto 1 do unview_sprite(s_list[t],n);
         putimage(x_pos,y_pos,savep^,0);
         freemem(savep,memuse);
         savep:=nil;
         clear_o_list(n);
         if o_nr>0 then for t:=1 to o_nr do review_sprite(s_list[t],n);
         sprite_error:=0;
         end;
      end;
   end;
end;

procedure print_sprite (n,x,y,e,m : integer);
var t : integer;
begin
if not nummer_ok(n) then sprite_error:=-6 else with sprite_feld[n] do begin
   if frei=true then sprite_error:=-7 else begin
      if not extras_ok(e,m) then sprite_error:=-9 else begin
         get_koords(n,x,y,e);
         if not koords_ok(x,y,x_gr,y_gr) then sprite_error:=-8 else begin
            sprite_error:=0;
            putimage(x,y,datenp^,m);
            end;
         end;
      end;
   end;
end;

procedure move_sprite (n,x,y : integer);
var t,u : integer;
begin
hide_sprite(n);
if sprite_error=0 then with sprite_feld[n] do begin
   show_sprite(n,x,y,e_merk,m_merk);
   if sprite_error<>0 then begin
      case e_merk of
         0 : ;
         1 : x:=x_pos+x_gr-1;
         2 : begin
                x:=x_pos+x_gr-1;
                y:=y_pos+y_gr-1;
                end;
         3 : y:=y_pos+y_gr-1
         end;
      show_sprite(n,x_pos,y_pos,e_merk,m_merk);
      end;
   end;
end;

procedure sprite_pos(n : integer ; var x,y : integer);
begin
if not nummer_ok(n) then sprite_error:=-6 else begin
   if sprite_feld[n].frei then sprite_error:=-7 else with sprite_feld[n] do
   if savep=nil then sprite_error:=-10 else begin
      x:=x_pos;
      y:=y_pos;
      case e_merk of
         0 : ;
         1 : x:=x+x_gr-1;
         2 : begin
                x:=x+x_gr-1;
                y:=y+y_gr-1;
                end;
         3 : y:=y+y_gr-1
         end;
      sprite_error:=0;
      end;
   end;
end;

function sprite_kol(n : integer) : boolean;
var t : integer;
begin
if not nummer_ok(n) then sprite_error:=-6 else begin
   if sprite_feld[n].frei then sprite_error:=-7 else
   if sprite_feld[n].savep=nil then sprite_error:=-10 else begin
      sprite_kol:=false;
      for t:=0 to max_sprites-1 do begin
          kol_list[t]:=false;
          if not sprite_feld[t].frei then if sprite_feld[t].savep<>nil then
          if sprite_feld[t].o_list[n]>0 then begin
             sprite_kol:=true;
             kol_list[t]:=true;
             end;
          end;
      if sprite_feld[n].o_nr>0 then with sprite_feld[n] do begin
         sprite_kol:=true;
         for t:=1 to o_nr do kol_list[s_list[t]]:=true;
         end;
      sprite_error:=0;
      end;
   end;
end;

begin
for init_count:=0 to max_sprites-1 do begin
    sprite_feld[init_count].frei:=true;
    sprite_feld[init_count].savep:=nil;
    end;
end.